;For compiler, speedup hacks.

(declare (mapex t)
	 (macros t)
         (special **beta** **vals** **unevlis** **evlis** **pc** **clink**
                  **nexp** **nbeta** **nvals** **fun**
                  **val** **tem** **fluid!vars** **fluid!vals**
                  **queue** **tick** **quantum** **process** **procnum**
                  version lispversion))

(defun version macro (x)
       (cond (compiler-state (list 'quote (status uread)))
	     (t (rplaca x 'quote)
		(rplacd x (list version))
		(list 'quote version))))

(declare (read))

(setq version ((lambda (compiler-state) (version)) t))

(defun fastcall (atsym)
       (cond ((eq (car (cdr atsym)) 'subr)
	      (subrcall nil (cadr (cdr atsym))))
	     (t ((lambda (subr)
			 (cond (subr (remprop atsym 'subr)
				     (putprop atsym
					      subr
					      'subr)
				     (subrcall nil subr))
			       (t (apply atsym nil))))
		 (get atsym 'subr)))))

(defun saveup macro (l)
      '(setq **clink** 
             (cons **pc**
                   (cons **vals**
                         (cons **unevlis**
                               (cons **evlis**
                                     (cons **beta** **clink**)))))))

(defun restore macro (l)
    '(prog (ltem)
        (setq ltem **clink**
             **pc** (car ltem)
              ltem (cdr ltem)
             **vals** (car ltem)
              ltem (cdr ltem)
             **unevlis** (car ltem)
              ltem (cdr ltem)
             **evlis** (car ltem)
              ltem (cdr ltem)
             **beta** (car ltem)
             **clink** (cdr ltem))))

(defun push macro (l)
       (list 'setq '**clink** (list 'cons (cadr l) '**clink**)))

(defun pop macro (l)
       (list 'setq (cadr l) '(car **clink**) '**clink** '(cdr **clink**)))

(defun primop macro (x) (list 'getl (cadr x) ''(subr expr lsubr))))

(defun betacons (lamb obeta ovals name)
       (cons 'beta
             (cons (reverse (cadr lamb))
                   (cons (cons obeta ovals)
                         (cons (caddr lamb) name)))))

(defun bind (newvars newvals name)
       (setq **nbeta** (cons name
                             (cons newvars
                                   (cons (cons **nbeta** **nvals**)
                                         nil)))
             **nvals** newvals))

(defun vars macro (l) (list 'cadr (cadr l)))

(defun obeta macro (l) (list 'caaddr (cadr l)))

(defun ovals macro (l) (list 'cdaddr (cadr l)))

(defun body macro (l) (list 'cadddr (cadr l)))

(defun name macro (l) (list 'cddddr (cadr l)))

(defun lookup (identifier beta vals)
       (prog (vars)
        nextbeta
           (setq vars (vars beta))
        nextvar
           (cond ((null vars)
                  (setq vals (ovals beta))
                  (cond ((setq beta (obeta beta)) (go nextbeta))
                        (t (return nil))))
                 ((eq identifier (car vars)) (return vals))
                 (t (setq vars (cdr vars)
                          vals (cdr vals))
                    (go nextvar)))))

;Basic interpreter -- initialization, main-loop, time slicing.

(defprop moonphase (phase fasl dsk gls) autoload)
(defprop phaseprinc (phsprt fasl dsk gls) autoload)
(defprop datimprinc (phsprt fasl dsk gls) autoload)

(defun scheme ()
       (setq version (version)  lispversion (status lispversion))
       (terpri)
       (princ '|This is SCHEME |)
       (princ version)
       (princ '| running in LISP |)
       (princ lispversion)
       (princ '|.|)
       (terpri)
       (datimprinc)
       (terpri)
       (phaseprinc (moonphase))
       (setq **beta** nil  **vals** nil  **fluid!vars** nil  **fluid!vals** nil
	     **queue** nil
             **process** (create!process '(**top** '|SCHEME -- Toplevel| '|==> |)))
       (swapinprocess)
       (alarmclock 'runtime **quantum**)
       (mloop))

(setq **top**
      '(lambda (**message** **prompt**)
               (labels ((**top1**
                          (lambda (**ignore1** **ignore2** **ignore3**)
                             (**top1** (terpri) (princ **prompt**)
                                       (print (set '# (evaluate (read))))))))
                    (**top1** (terpri) (princ **message**) nil))))

(defun mloop ()
       (do ((**tick** nil))  (nil)
          (and **tick** (allow) (schedule))
          (fastcall **pc**)))

(defun allow ()
  ((lambda (vcell)
       (cond (vcell (car vcell))
             (t t)))
   (lookup '*allow* **beta** **vals**)))

(defun schedule ()
       (cond (**queue**
	      (swapoutprocess)
	      (nconc **queue** (list **process**))
	      (setq **process** (car **queue**)
		    **queue** (cdr **queue**))
	      (swapinprocess)))
       (setq **tick** nil)
       (alarmclock 'runtime **quantum**))

(defun swapoutprocess ()
       (putprop **process**
                (list **beta** **vals** **evlis** **unevlis** **pc** **clink**
                      **nexp** **nbeta** **nvals** **fluid!vars**
		      **fluid!vals** **val** **tem**)
                '**process**))

(defun swapinprocess () 
       (mapc 'set
             '(**beta** **vals** **evlis** **unevlis** **pc** **clink**
               **nexp** **nbeta** **nvals** **fluid!vars**
	       **fluid!vals** **val** **tem**)
             (get **process** '**process**) ))

(defun settick (x) (setq **tick** t))
(setq **quantum** 1000000. alarmclock 'settick)

;Central evaluator functions.

(defun dispatch ()
       (cond ((atom **nexp**)
              (cond ((numberp **nexp**) (setq **val** **nexp**))
                    ((setq **val** (primop **nexp**)))
                    ((setq **tem** (lookup **nexp** **nbeta** **nvals**))
                     (setq **val** (car **tem**)))
                    (t (setq **val** (symeval **nexp**)))))
             ((atom (car **nexp**))
              (cond ((setq **tem** (get (car **nexp**) 'aint))
                     (fastcall **tem**))
                    ((setq **tem** (get (car **nexp**) 'amacro))
                     (setq **nexp** (funcall **tem** **nexp**))
                     (dispatch))
                    ((eq (car **nexp**) 'lambda)
                     (setq **val** (betacons **nexp** **nbeta** **nvals** **nexp**)))
                    (t (saveup)
                       (setq **beta** **nbeta**  **vals** **nvals**
                             **unevlis** (cdr **nexp**)  **nexp** (car **nexp**)
                             **pc** 'gotfun)
                       (dispatch))))
             (t (saveup)
                (setq **beta** **nbeta**  **vals** **nvals**  **unevlis** (cdr **nexp**)
                      **nexp** (car **nexp**)  **pc** 'gotfun)
                (dispatch))))

(defun gotfun ()
       (setq **fun** **val**)
       (and (eq (car **fun**) 'lambda)
            (setq **fun** (betacons **fun** **beta** **vals** **fun**)))
       (push **fun**)
       (setq **evlis** nil)
       (evlis))

(defun evlis ()
       (cond ((null **unevlis**)
              (pop **fun**)
              (cond ((eq (car **fun**) 'subr)
                     (setq **val** (revsubrapply **fun** **evlis**))
                     (restore))
		    ((eq (car **fun**) 'lsubr)
		     (setq **val** (revlsubrapply **fun** **evlis**))
		     (restore))
		    ((eq (car **fun**) 'expr)
		     (setq **val** (revapply (cadr **fun**) **evlis**))
		     (restore))
                    ((eq (car **fun**) 'beta)
                     (setq **nexp** (body **fun**)
                           **nbeta** **fun**
                           **nvals** **evlis**)
                     (restore)
                     (dispatch))
                    ((eq (car **fun**) 'delta)
                     (setq **clink** (cadr **fun**))
                     (setq **fluid!vars** (caddr **fun**))
		     (setq **fluid!vals** (cadddr **fun**))
                     (restore))
                    (t (error '|Bad Function - Evlis| **fun** 'fail-act))))
             (t (setq **nexp** (car **unevlis**)
                      **nbeta** **beta**
                      **nvals** **vals**
                      **pc** 'evlis1)
                (dispatch))))

(defun evlis1 ()
 (setq **evlis** (cons **val** **evlis**)  **unevlis** (cdr **unevlis**))
 (evlis))

(defun revapply (fn values)
       (prog (a b c d e vals)
	     (or values (return (funcall fn)))
	     (setq a (car values) vals (cdr values))
	     (or vals (return (funcall fn a)))
	     (setq b (car vals) vals (cdr vals))
	     (or vals (return (funcall fn b a)))
	     (setq c (car vals) vals (cdr vals))
	     (or vals (return (funcall fn c b a)))
	     (setq d (car vals) vals (cdr vals))
	     (or vals (return (funcall fn d c b a)))
	     (setq e (car vals) vals (cdr vals))
	     (or vals (return (funcall fn e d c b a)))
	     (return (apply fn (reverse values)))))

(defun revsubrapply (fn values)
       (prog (a b c d e vals)
	     (or values (return (subrcall nil (cadr fn))))
	     (setq a (car values) vals (cdr values))
	     (or vals (return (subrcall nil (cadr fn) a)))
	     (setq b (car vals) vals (cdr vals))
	     (or vals (return (subrcall nil (cadr fn) b a)))
	     (setq c (car vals) vals (cdr vals))
	     (or vals (return (subrcall nil (cadr fn) c b a)))
	     (setq d (car vals) vals (cdr vals))
	     (or vals (return (subrcall nil (cadr fn) d c b a)))
	     (setq e (car vals) vals (cdr vals))
	     (or vals (return (subrcall nil (cadr fn) e d c b a)))
	     (error '|Too Many Arguments to a Subr| (cons fn values) 'wrng-no-args)))

(defun revlsubrapply (fn values)
       (prog (a b c d e vals)
	     (or values (return (lsubrcall nil (cadr fn))))
	     (setq a (car values) vals (cdr values))
	     (or vals (return (lsubrcall nil (cadr fn) a)))
	     (setq b (car vals) vals (cdr vals))
	     (or vals (return (lsubrcall nil (cadr fn) b a)))
	     (setq c (car vals) vals (cdr vals))
	     (or vals (return (lsubrcall nil (cadr fn) c b a)))
	     (setq d (car vals) vals (cdr vals))
	     (or vals (return (lsubrcall nil (cadr fn) d c b a)))
	     (setq e (car vals) vals (cdr vals))
	     (or vals (return (lsubrcall nil (cadr fn) e d c b a)))
	     (setplist 'the-lsubr-apply-atom fn)
	     (return (apply 'the-lsubr-apply-atom (reverse values)))))

;Basic AINTs.

(defprop evaluate aeval aint)

(defun aeval ()
       (saveup)
       (setq **beta** **nbeta**  **vals** **nvals**
             **nexp** (cadr **nexp**)  **pc** 'aeval1)
       (dispatch))

(defun aeval1 ()
       (setq **nexp** **val**  **nbeta** **beta**  **nvals** **vals**)
       (restore)
       (dispatch))


(defprop if aif aint)

(defun aif ()
       (saveup)
       (setq **beta** **nbeta**  **vals** **nvals**  **evlis** **nexp**
             **nexp** (cadr **nexp**)  **pc** 'if1)
       (dispatch))

(defun if1 ()
       (setq **nbeta** **beta**  **nvals** **vals**
             **nexp** (cond (**val** (caddr **evlis**)) (t (cadddr **evlis**))))
       (restore)
       (dispatch))


(defprop test atest aint)

(defun atest ()
       (saveup)
       (setq **beta** **nbeta**  **vals** **nvals**  **evlis** **nexp**
             **nexp** (cadr **nexp**)  **pc** 'test1)
       (dispatch))

(defun test1 ()
       (setq **nbeta** **beta**  **nvals** **vals**)
       (cond (**val**
	      (setq **nexp** (caddr **evlis**)  **evlis** (list **val**)
                    **pc** 'test2)
	      (dispatch))
	     (t (setq **nexp** (cadddr **evlis**))
                (restore)
                (dispatch))))

(defun test2 ()
       (and (eq (car **val**) 'lambda)
            (setq **val** (betacons **val** **beta** **vals** **val**)))
       (push **val**)
       (setq **unevlis** nil)
       (evlis))

(defprop quote aquote aint)

(defun aquote () (setq **val** (cadr **nexp**)))


(defprop labels alabels aint)

(defun alabels ()
       (bind (mapcar 'car (cadr **nexp**))
             (mapcar 'car (cadr **nexp**))
             'labels)
       (map '(lambda (defl vall)
		     (rplaca vall
			     (betacons (cadar defl)
				       **nbeta**
				       **nvals**
				       (caar defl))))
	    (cadr **nexp**)
	    **nvals**)
       (setq **nexp** (caddr **nexp**))
       (dispatch))


;Side effects.

(defprop define adefine aint)

(defun adefine () (setq **val** (eval **nexp**)))

(defun define fexpr (l)
       (setq **tem** (cond ((cdr l) (putprop (car l) (cadr l) 'scheme!function))
                           ((get (car l) 'scheme!function))
                           (t (error '|Bad Definition - Define| l 'fail-act))))
       (set (car l) (betacons **tem** nil nil (car l)))
       (car l))


(defun aset (var val)
       ((lambda (vc)
                (cond (vc (rplaca vc val))
                      (t (set var val))))
        (lookup var **beta** **vals**)))

;Fluid variable stuff.

(defprop fluid!bind afluidbind aint)

(defun afluidbind ()
       (saveup)
       (setq **beta** **nbeta**
	     **vals** **nvals**
	     **unevlis** (cadr **nexp**)
	     **evlis** **fluid!vals**)
       (push **nexp**)
       (afluidbind1))

(defun afluidbind1 ()
       (cond ((null **unevlis**)
	      (pop **nexp**)
	      (setq **tem**
		    (do ((z (cadr **nexp**) (cdr z))
			 (y **fluid!vars** (cons (caar z) y)))
			((null z) y)))
	      (setq **unevlis** **fluid!vals**
		    **fluid!vals** **evlis**
		    **evlis** **fluid!vars**
		    **fluid!vars** **tem**
		    **nexp** (caddr **nexp**)
		    **pc** 'unbind)
	      (dispatch))
	     (t (setq **nexp** (cadar **unevlis**)
		      **nbeta** **beta**
		      **nvals** **vals**
		      **pc** 'afluidbind2)
		(dispatch))))

(defun afluidbind2 ()
       (setq **evlis** (cons **val** **evlis**)
	     **unevlis** (cdr **unevlis**)
	     **pc** 'afluidbind1))

(defun unbind ()
       (setq **fluid!vars** **evlis**)
       (setq **fluid!vals** **unevlis**)
       (restore))

(defprop fluid!value afluidval aint)

(defun afluidval ()
       (setq **val**
	     ((lambda (vc)
		      (cond (vc (car vc))
			    (t (symeval (cadr **nexp**)))))
	      (fluid!lookup (cadr **nexp**) **fluid!vars** **fluid!vals**))))


(defun fluid!set (var val)
       ((lambda (vc)
                (cond (vc (rplaca (cdr vc) val))
                      (t (set var val))))
        (fluid!lookup var **fluid!vars** **fluid!vals**)))

(defun fluid!lookup (id vars vals)
       (prog ()
         lp (cond ((null vars) (return nil))
                  ((eq id (car vars))
                   (cond ((null vals) (error '|Vals too short -- fluid!lookup| id 'fail-act)))
                   (return vals))
                  ((null vals) (error '|Too few vals - fluid!lookup| id 'fail-act)))
            (setq vars (cdr vars)  vals (cdr vals))
            (go lp)))

;Hairy control structure.

(setq **procnum** 0)

(defun genprocname ()
       ((lambda (base *nopoint)
		(maknam (append '(p r o c e s s)
			        (exploden (setq **procnum** (1+ **procnum**))))))
	10. t))

(defun create!process (exp)
       ((lambda (**process** **beta** **vals** **evlis** **unevlis** **pc** **clink**
                 **nexp** **nbeta** **nvals** **fluid!vars** **fluid!vals**
		 **val** **tem**)
                (dispatch)
                (swapoutprocess)
                **process**)
        (genprocname) nil nil nil nil 'terminate nil
        exp **beta** **vals** **fluid!vars** **fluid!vals**
	nil nil))

(defun start!process (p)
       (cond ((or (not (atom p)) (not (get p '**process**)))
	      (error '|Bad Process - START!PROCESS| p 'fail-act)))
       (or (eq p **process**) (memq p **queue**)
	   (setq **queue** (nconc **queue** (list p))))
       p)

(defun stop!process (p)
       (cond ((memq p **queue**)
	      (setq **queue** (delete p **queue**))
              p)
	     ((eq p **process**)
              (setq **val** p)
              (terminate))))

(defun terminate ()
       (restore)
       (swapoutprocess)
       (cond ((null **queue**)
	      (setq **beta** nil  **vals** nil  **fluid!vars** nil  **fluid!vals** nil)
	      (setq **process**
		    (create!process '(**top** '|SCHEME -- Queueout| '|==> |))))
	     (t (setq **process** (car **queue**)
		      **queue** (cdr **queue**))))
       (swapinprocess)
       (saveup)
       **val**)


(defprop evaluate!uninterruptibly evun aint)

(defun evun ()
       (bind (list '*allow*) (list nil) 'evaluate!unterruptibly)
       (setq **nexp** (cadr **nexp**))
       (dispatch))


(defprop catch acatch aint)

(defun acatch ()
       (bind (list (cadr **nexp**))
             (list (list 'delta
			 ((lambda (**clink**) (saveup)) **clink**)
			 **fluid!vars**
			 **fluid!vals**
			 (cadr **nexp**)))
             'catch)
       (setq **nexp** (caddr **nexp**))
       (dispatch))

(defun where ()
       (do ((prinlevel 3) (prinlength 6)
            (b **beta** (obeta b)))
           ((null b) nil)
          (cond ((eq (car b) 'beta) (print (name b)))
                (t (print (car b))))))

(defun whereall fexpr (x)
       (do ((**clink** **clink**)
	    (**beta** **beta**)
	    (**evlis**)
	    (**unevlis**)
	    (**pc**)
	    (**vals**)
	    (prinlevel 3)
	    (prinlength 6))
	   ((atom **clink**))
	   (cond ((atom (car **clink**))
		  (restore))
		 (t (do ((frob))
			((atom (car **clink**))
			 (where)
			 (and (memq 'vars x) (wherevars))
			 (restore))
			(pop frob)
			(terpri)
			(princ '|=== Evalargs for |)
			(prin1 frob))))))

(defun wherevars ()
       (cond ((obeta **beta**)
	      (terpri)
	      (princ '|Variable bindings:|)
	      (do ((beta **beta** (obeta beta)))
		  ((null (obeta beta)))
		  (mapc '(lambda (var val)
				 (terpri)
				 (princ '|   |)
				 (prin1 var)
				 (tyo 11)
				 (prin1 val))
			(vars (obeta beta))
			(ovals beta))))))

(defun what fexpr (x)
       (lookup (car x) **beta** **vals**))
ββ